home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / appleEvents.tcl < prev    next >
Encoding:
Text File  |  2000-12-15  |  10.6 KB  |  389 lines
  1. # JEG - modernized
  2. # 
  3. # make alias list to pass to AEBuild
  4. proc makeAlis {name} {
  5.     return [tclAE::build::alis $name]
  6. }
  7.  
  8. # JEG - This is unused???
  9. proc makeFile {name} {
  10.     return [tclAE::build::alis $name]    
  11. }
  12.  
  13. ## 
  14.  # -------------------------------------------------------------------------
  15.  # 
  16.  # "makeAlises" --
  17.  # 
  18.  #  This proc has changed so it takes a list of items rather than an
  19.  #  unknown number of args 'args'.  If 'l' is a list you must call
  20.  #  this proc with 'makeAlises $l' rather than 'eval makeAlises $l'
  21.  #  as was previously required.
  22.  # -------------------------------------------------------------------------
  23.  ##
  24.  
  25. # JEG - modernized
  26. # 
  27. proc makeAlises {names} {
  28.     return [tclAE::build::List $names -untyped -as alis]
  29. }
  30.  
  31. ## 
  32.  # -------------------------------------------------------------------------
  33.  # 
  34.  # "handleReply" --
  35.  # 
  36.  #  Queued replies are passed through AEPrint and then to this routine.
  37.  #  
  38.  #  If you write your own handleReply procedure, register it to this
  39.  #  proc with:
  40.  #  
  41.  #    currentReplyHandler 'my-proc-name'
  42.  #    
  43.  #  Do this each time you send an event which may receive a reply.
  44.  #  There is no need to register your proc at startup or any such
  45.  #  'pre-registering'.  Just call the above proc _each_ time.
  46.  #  
  47.  #  You proc should take one parameter (the reply), and should
  48.  #  return '1' if it handled the reply, otherwise it can do/return
  49.  #  anything else (although hopefully not much if it didn't handle
  50.  #  anything).
  51.  #  
  52.  #  If your replies often time-out or have other problems such
  53.  #  that you don't handle them correctly, you may wish to register
  54.  #  your reply-handler with 'currentReplyHandler 'my-proc' 1' which
  55.  #  says 'only register if it's not already registered'.  Or you
  56.  #  may wish to remove duplicates from the list of handlers 
  57.  #  directly.
  58.  #    
  59.  # Results:
  60.  #  depends on what is registered
  61.  # 
  62.  # Side effects:
  63.  #  calls other procs.  Removes handler from queue if it handled
  64.  #  the reply.
  65.  # 
  66.  # --Version--Author------------------Changes-------------------------------
  67.  #    1.0     <vince@santafe.edu> first one with hook handling
  68.  #    2.0     <vince@santafe.edu> different mechanism to give priority
  69.  # -------------------------------------------------------------------------
  70.  ##
  71. proc handleReply {rep} {
  72.     global lastReply replyHandlers
  73.     set lastReply $rep
  74.     set i 0
  75.     foreach h $replyHandlers {
  76.     if {$h != ""} {
  77.         set cmd [concat $h [list $rep]]
  78.         catch $cmd res
  79.         if {$res == 1} {
  80.         set replyHandlers [lreplace $replyHandlers $i $i]
  81.         return
  82.         }
  83.     }
  84.     incr i
  85.     }
  86.     message "Reply '$rep' not handled"
  87. }
  88.  
  89. ensureset replyHandlers ""
  90.  
  91. ## 
  92.  # -------------------------------------------------------------------------
  93.  # 
  94.  # "currentReplyHandler" --
  95.  # 
  96.  #  Add item to end of queue to receive replies, even if it is already
  97.  #  in the queue, unless we set 'nodups'
  98.  # -------------------------------------------------------------------------
  99.  ##
  100. proc currentReplyHandler {proc {nodups 0}} {
  101.     global replyHandlers
  102.     if {!$nodups || (![lcontains replyHandlers $proc])} {
  103.     lappend replyHandlers $proc
  104.     }    
  105. }
  106.  
  107. # JEG - only used by thinkMenu.tcl. Why is it here?
  108. # 
  109. # Return an object record specifying the desired think project file.
  110. proc fileObject {name} {
  111.     join [concat {obj\{want:type('SFIL'), from:'null'(), form:'name', seld:“} [file tail $name] {”\}}] ""
  112. }
  113.  
  114. #• sendOpenEvent [filler] <app name> <file name> - Send an open doc event to 
  115. #  another currently running application. If 'filler' is noReply, then a 
  116. #  reply is not requested. Otherwise, we wait for a reply and 'filler' is 
  117. #  ignored. 
  118. proc sendOpenEvent {filler app filename} {
  119.     global browserSig tcl_platform
  120.     set filename [file nativename $filename]
  121.     switch -- $tcl_platform(platform) {
  122.     "windows" {
  123.         set app [string trim $app ']
  124.         if {[file nativename $app] == [file nativename $browserSig]} {
  125.         global env
  126.         # This command doesn't seem to work with long names/spaces etc
  127.         # on windows, so we convert to the shortname!
  128.         set filename [file attributes $filename -shortname]
  129.         exec $env(COMSPEC) /c start $filename &
  130.         return
  131.         } elseif {$app == "Finder"} {
  132.         if {[file isdirectory $filename]} {
  133.             windows::Show $filename
  134.         } else {
  135.             windows::Launch $filename
  136.         }
  137.         } else {
  138.         if {$filler == "noReply"} {
  139.             exec $app $filename &
  140.         } else {
  141.             return [exec $app $filename]
  142.         }
  143.         }
  144.     }
  145.     "macintosh" {
  146.         global file::separator
  147.         
  148.         # Tcl 8's [file nativename] strips the trailing ':'
  149.         # from directories which screws up the 'alis'
  150.         if {[file type $filename] == "directory" \
  151.           && ![regexp "${file::separator}\$" $filename]} {
  152.         append filename ${file::separator}
  153.         }
  154.         if {$filler == "noReply"} {
  155.         AEBuild $app aevt odoc "----" [makeAlis $filename]
  156.         } else {
  157.         AEBuild -r $app aevt odoc "----" [makeAlis $filename]
  158.         }
  159.     }
  160.     "unix" {
  161.         set app [string trim $app ']
  162.         if {$filler == "noReply"} {
  163.         exec $app $filename &
  164.         } else {
  165.         return [exec $app $filename]
  166.         }
  167.     }
  168.     }
  169.     
  170. }
  171.  
  172. proc launchDoc {name} {
  173.     set app [app::launchFore [getFileSig $name]]
  174.     sendOpenEvent -r [file tail $app] $name
  175. }
  176.  
  177. # Send multiple open events
  178. proc sendOpenEvents {appname args} {
  179.     AEBuild -r $appname aevt odoc "----" [makeAlises $args]
  180. }
  181.  
  182. proc openAndSendFile {sig} {
  183.     set fname [win::Current]
  184.     if {[winDirty]} {
  185.     if {[dialog::yesno "Save '$fname'?"]} {
  186.         save
  187.     }
  188.     }
  189.     
  190.     set name [file tail [app::launchFore $sig]]
  191.     sendOpenEvent noReply $name $fname
  192. }
  193.  
  194. #================================================================================
  195. # General Apple Event handling routines
  196. #
  197. # (written by Tom Pollard for use in the MacPerl package)
  198. #================================================================================
  199.  
  200. # Quit an application.
  201. proc sendQuitEvent {appname} {
  202.     AEBuild $appname "aevt" "quit" 
  203. }
  204.  
  205. # Close one of an application's windows, designated by number.
  206. proc sendCloseWinNum {appname num} {
  207.     AEBuild $appname "core" "clos" "----" [AEWinByPos $num]
  208. }
  209.  
  210. # Close one of an application's windows, designated by name.
  211. proc sendCloseWinName {appname name} {
  212.     AEBuild $appname "core" "clos" "----" [AEWinByName $name]
  213. }
  214.  
  215. # Obtain the number of lines in one of an application's
  216. # windows, designated by name.
  217. proc sendCountLines {appname name} {
  218.     set winObj [AEWinByName $name]
  219.     set res [AEBuild -r $appname "core" "cnte" "----" $winObj kocl type('clin')]    
  220.     if {[regexp {:(.*)\}} $res allofit nlines]} {
  221.     return $nlines
  222.     } else {
  223.     return 0
  224.     }
  225. }
  226.  
  227. # Get a selected range of lines from one of an application's
  228. # windows, designated by name.  If $last is missing, then a single
  229. # line is returned; if both $first and $last are missing, then
  230. # the complete window contents are returned.
  231. proc sendGetText {appname name {first {missing}} {last {missing}}} {
  232.     global ALPHA
  233.     set winObj [AEWinByName $name]
  234.     if {$first != "missing"} {
  235.     if {$last != "missing"} {
  236.         set rangDesc [AELineRange $first $last]
  237.     } else {
  238.         set rangDesc [AEAbsPos $first]
  239.     }
  240.     set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
  241.     } else {
  242.     set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
  243.     }
  244.     set res [AEBuild -r $appname "core" "getd" "----" $objDesc]
  245.     if {![regexp {“.*”} $res text]} { set text {} }
  246.     return [string trim $text {“”}]
  247. }
  248.  
  249. # Set a selected range of lines in one of an application's
  250. # windows, designated by name.  If $last is missing, then a single
  251. # line is changed; if both $first and $last are missing, then
  252. # the complete window contents are replaced by the new text.
  253. proc sendSetText {appname name text {first {missing}} {last {missing}}} {
  254.     set winObj [AEWinByName $name]
  255.     if {$first != "missing"} {
  256.     if {$last != "missing"} {
  257.         set rangDesc [AELineRange $first $last]
  258.     } else {
  259.         set rangDesc [AEAbsPos $first]
  260.     }
  261.     set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
  262.     } else {
  263.     set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
  264.     }
  265.     set res [AEBuild -r $appname "core" "setd" "----" $objDesc "data" [curlyq $text]]    
  266.     if {![regexp {“.*”} $res text]} { set text {} }
  267.     return [string trim $text {“”}]
  268. }
  269.  
  270. ################################################################################
  271. # Utility functions for constructing AppleEvent descriptors for AEBuild
  272. ################################################################################
  273.  
  274. # JEG - modernized
  275. #
  276. proc AEFilename {name} {
  277.     return [tclAE::build::filename $name]
  278. }
  279.  
  280. # JEG - modernized
  281. #
  282. proc AEWinByName {name} {
  283.     return [tclAE::build::winByName $name]
  284. }
  285.  
  286. # JEG - modernized
  287. #
  288. proc AEWinByPos {absPos} {
  289.     return [tclAE::build::winByPos $absPos]
  290. }
  291.  
  292. # JEG - modernized
  293. #
  294. proc AELineRange {absPos1 absPos2} {
  295.     return [tclAE::build::lineRange $absPos1 $absPos2]
  296. }
  297.  
  298. # JEG - modernized
  299. #
  300. proc AEAbsPos {posName} {
  301.     return [tclAE::build::absPos $posName]
  302. }
  303.  
  304. # JEG - modernized
  305. #
  306. proc AEName {name} {
  307.     return [tclAE::build::name $name]
  308. }
  309.  
  310. # JEG - modernized
  311. #
  312. proc curlyq {str} {
  313.     return [tclAE::build::TEXT $str]
  314. }
  315.  
  316. ################################################################################
  317.  
  318. # JEG - modernized
  319. #
  320. proc nullObject {} { 
  321.     return [tclAE::build::nullObject] 
  322. }
  323.  
  324. # JEG - modernized
  325. #
  326. proc objectType {type} {
  327.     return [tclAE::build::objectType $type]
  328. }
  329.  
  330. # JEG - modernized
  331. #
  332. proc nameObject {type name from} {
  333.     return [tclAE::build::nameObject $type $name $from]
  334. }
  335.  
  336. # JEG - modernized
  337. #
  338. proc indexObject {type ind from} {
  339.     return [tclAE::build::indexObject $type $ind $from]
  340. }
  341.  
  342. # JEG - modernized
  343. #
  344. proc propertyObject {prop object} { 
  345.     return [tclAE::build::propertyObject $prop $object]
  346. }
  347.  
  348.  
  349. # JEG - unused?
  350. # 
  351. # 'process' must have single quotes
  352. proc buildMsgReply { process suite event args } { return [eval [list AEBuild -r $process $suite $event ] $args] }
  353.  
  354. # JEG - modernized
  355. #
  356. proc countObjects { process fromObject class } {
  357.     return [tclAE::build::resultData $process core cnte \
  358.       ---- $fromObject \
  359.       kocl [tclAE::build::objectType $class] \
  360.     ]
  361. }
  362.  
  363. proc createThingAtEnd {process container class} {
  364.     set res [AEBuild -r $process core crel insh "insl \{kobj:$container\}" kocl "type($class)"]
  365. }
  366.  
  367.  
  368. proc getObjectData { process class name from } {
  369.     set res [AEBuild -r $process core getd ---- [nameObject $class "“$name”" $from] {rtyp{type:TEXT}}]
  370.     if {[regexp {“(.*)”} $res dummy mtch]} {
  371.     return $mtch
  372.     } else {
  373.     error "Bad count proc"
  374.     }
  375. }
  376.  
  377.  
  378. proc objectProperty { process property object } {
  379.     AEBuild -r $process core getd ---- [propertyObject $property $object]
  380. }
  381.  
  382. # Extract and return a path from a result.
  383. proc extractPath {res} {
  384.     if {[regexp {«(.*)»} $res dummy fss]} {
  385.     return [specToPathName $fss]
  386.     }
  387.     error "bad path $name"
  388. }    
  389.